Shareware Grab Bag/Shareware Grab Bag.iso/001/wwiv.arc/COMMON.PAS

Pascal/Delphi Source File | 1986-04-07 | 31KB | 1,198 lines

CONST strlen=160;
      comnum=1;
      maxbaud=1200;
      maxusers=500;
      dsaves : Integer = 0;
      buffer_Max    = 5120;
      comptyp:array[1..8] of string[14]=('IBM','APPLE','TRS-80','Z-80 CP/M',
                 'COMMODORE','ATARI','DUMB TERMINAL','OTHER');

TYPE str=string[strlen];
     restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
                   rpost,remail,rvoting,rmsg);
     acrq='@'..'G';
     newtyp=(rp,lt,rm);
     deflts=(spcsr,onekey,wordwrap,pause);
     anontyp=(no,yes,forced,dearabby);
     ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
     opts=(alert,smw,nomail);
     pnr=record name:string[40]; number:string[14]; hs:byte; end;
     slr=record
           ttime:byte;
           mallowed:integer;
           emails,posts:byte;
           anst:set of ansttype;
         end;
     messages=record
                ltr:char;
                number:integer;
                ext:byte;
              end;
     smalrec=record
               name:string[25];
               number:integer;
             end;
     userrec=record
               name:string[25];
               realname:string[14];
               deleted:boolean;
               pw:string[8];
               ph:string[12];
               waiting:byte;
               laston:string[10];
               loggedon:integer;
               msgpost:integer;
               emailsent:integer;
               feedback:integer;
               linelen:byte;
               pagelen:byte;
               defaults:set of deflts;
               ontoday:byte;
               illegal:byte;
               cursor:string[10];
               sl:byte;
               ac:set of restrictions;
               ar:set of acrq;
               qscan:array[1..19] of messages;
               qscn:array[1..19] of boolean;
               macro:array[1..2] of string[79];
               comptype:byte;
               option:set of opts;
               vote:array[1..9] of byte;
               sbn:byte;
               dsl:byte;
               uploads,downloads:integer;
               uk,dk:integer;
             end;
      boardrec=record
                 name:string[25];
                 filename:string[12];
                 sl:byte;
                 maxmsgs:byte;
                 pw:string[10];
                 anonymous:anontyp;
                 ar:acrq;
                 key:char;
               end;
      msgstat=(validated,unvalidated,deleted);
      messagerec=record
                   title:string[30];
                   messagestat:msgstat;
                   message:messages;
                   owner:integer;
                   date:integer;
                   mage:byte;
                 end;
      systatrec=record
                  boardpw:string[8];
                  sysoppw:string[8];
                  hmsg:messages;
                  users:integer;
                  lastdate:string[8];
                  callernum:integer;
                  activetoday:integer;
                  callstoday:integer;
                  msgposttoday:integer;
                  emailtoday:integer;
                  fbacktoday:integer;
                  uptoday:integer;
                  closedsystem:boolean;
                end;
      blk=array[1..255] of byte;
      mailrec=record
                title:string[30];
                from,destin:integer;
                msg:messages;
                date:integer;
                mage:byte;
              end;
      gft=record
            num:integer;
            title:string[40];
            filen:string[12];
          end;
      charfil=text;
      smr=record
            msg:str;
            destin:integer;
          end;
      vdatar=record
               question:string[79];
               numa:integer;
               answ:array[0..9] of record
                      ans:string[25];
                      numres:integer;
                    end;
             end;
      regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
      ulrec=record
              name:string[25];
              filename:string[12];
              password:string[10];
              dsl:byte;
              maxfiles:integer;
            end;
      ulfrec=record
               filename:string[12];
               description:string[60];
               res:array[1..17] of byte;
               ft:array[1..3] of byte;
               blocks:integer;
               owner:integer;
               date:string[8];
               daten:integer;
             end;
      strptr=^strrec;
      strrec=record
               i:str;
               next,last:strptr;
             end;

var sf:file of smalrec;
    uf:file of userrec;
    bf:file of boardrec;
    mf:file of messagerec;
    mailfile:file of mailrec;
    sysopf:charfil;
    slf:file of slr;
    seclev:array[0..255] of slr;
    systatf:file of systatrec;
    systat:systatrec;
    sr:smalrec;
    thisline,chatr,buf,spd,irt,lastname,ll,cursor,i:str;
    thisuser,user:userrec;
    boards:array[1..19] of boardrec;
    fw,extramsgs,mread,board,numboards,t,usernum:integer;
    pap,lil,realsl,ftoday,ptoday,etoday:integer;
    c,ID:char;
    hungup,useron,next,chatcall,expert,doneday,echo,hangup,incom,outcom:boolean;
    extratime,timeon:real;
    macok,lan,enddayf,ch,quit:boolean;
    buffer:Array[0..buffer_Max] of Char;
    comport,base:Integer;
    Async_Irq:Integer;
    buffer_Head,buffer_tail,buffer_newtail:Integer;
    smf:file of smr;
    srl:array[0..maxusers] of smalrec;
    vqu:array[1..9] of boolean;
    ret:byte absolute cseg:$0080;
    ldate:integer;
    maxspd:integer;
    cmd:char;
    help:array[1..25000] of char;
    helpi:array['0'..'^'] of integer;
    helpl:char;
    ihelp:boolean;
    cf:text; cfo,okt:boolean;
    elevel:byte;


function freek:integer;
var r:regs;
begin
  r.ax:=$3600;
  r.dx:=0;
  msdos(r);
  freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);
end;

function cs:boolean;
begin
  cs:=cosysop in seclev[thisuser.sl].anst;
end;

function so:boolean;
begin
  so:=thisuser.sl=255;
end;

function lcs:boolean;
begin
  lcs:=cs or ((lcosysop in seclev[thisuser.sl].anst) and ((board=thisuser.sbn) or (thisuser.sbn=0)));
end;

function commpressed : boolean;
begin
 commpressed := (buffer_tail<>buffer_head);
end;

procedure dump;
begin
  inline($FA);
  buffer_head:=0;
  buffer_tail:=buffer_head;
  inline($FB);
end;

procedure async_isr;
begin
  inline($50/$53/$52/$1E/$FB/$2E/$FF/$36/dsaves/$1F/$8B/$16/base/
         $EC/$8B/$1E/buffer_Head/$88/$87/buffer/$43/$81/$FB/buffer_Max/$7E/
         $02/$33/$DB/$3B/$1E/buffer_Tail/$74/$04/$89/$1E/buffer_Head/$FA/
         $B0/$20/$E6/$20/$1F/$5A/$5B/$58/$5C/$5D/$CF);
end;

procedure remove_port;
var
  i,m:integer;
begin
  inline($FA);
  i := port[$21];
  m := 1 shl Async_Irq;
  port[$21] := i or m;
  port[2+base] := 0;
  port[4+base] := 1;
  inline($FB);
end;

procedure term_ready(s:Boolean);
var x:byte;
begin
  x := port[4+base] and $FE;
  if s then x:=x+1;
  port[4+base] := x;
end;

procedure set_baud(r:integer);
var rl:real; a:byte;
begin
  if (r>=300) and (r<=9600) then begin
    rl:=115200.0/r;
    r:=trunc(rl);
    a:=port[3+base] or 128;
    port[base+3]:=a;
    port[base]:=lo(r);
    port[1+base]:=hi(r);
    port[3+base]:=a and 127;
  end;
end;


procedure iport;
var
   i,m:Integer;
   regs:record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
begin
  dsaves:= DSeg;
  If ComPort = 2 Then begin
    base := $2f8;
    Async_Irq  := 3;
  end else begin
    base := $3f8;
    Async_Irq  := 4;
  end;
  If (Port[2+base] and $00F8) <> 0 Then
    begin writeln('Illegal com port number'); halt; end
  else begin
    buffer_Head:=0; buffer_Tail:=0; port[base+3]:=$03;
    with regs do begin
      ax:=$2500+((async_irq+8) and $00ff); ds:=cseg;
      dx:=ofs(async_isr); msdos(regs);
    end;
    inline($FA);
    i:=port[5+base];
    i:=port[base];
    i:=port[$21];
    m:=(1 shl Async_Irq) xor $00FF;
    port[$21] := i and m;
    port[1+base] := $01;
    i := port[4+base];
    port[4+base] := i or $08;
    term_ready(true);
    inline($FB);
  end;
end;

function cinkey:char;
var t:char;
begin
  if buffer_Head = buffer_Tail Then
    t:=#0
  else begin
    inline($FA);
    t:=buffer[buffer_Tail];
    buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
    inline($FB);
  end;
  cinkey:=chr(ord(t) and 127);
end;

function cinkey1:char;
var t:char;
begin
  if buffer_Head = buffer_Tail Then
    t:=#0
  else begin
    inline($FA);
    t:=buffer[buffer_Tail];
    buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
    inline($FB);
  end;
  cinkey1:=t;
end;

procedure o1(c:char);
begin
  while (port[base+5] and 32)=0 do;
  port[base]:=ord(c);
end;

procedure o(c:char);
begin
  if outcom and (c<>#1) then o1(c);
end;

FUNCTION TIMER: REAL;

VAR REG: RECORD
           AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS: INTEGER;
         END;
    H,M,S,T: REAL;

BEGIN
  REG.AX := 44 * 256;
  MsDos(REG);
  H      := (REG.CX DIV 256);
  M      := (REG.CX MOD 256);
  S      := (REG.DX DIV 256);
  T      := (REG.DX MOD 256);
  TIMER  := H*3600 + M*60 + S + T/100;
END;

function sysop1:boolean;
begin
  if (mem[0:1047] and 16)=0 then sysop1:=false else sysop1:=true;
end;

function sysop:boolean;
begin
  sysop:=sysop1;
  if rchat in thisuser.ac then sysop:=false;
end;

procedure bs;
var x,y:integer;
begin
  x:=wherex; y:=wherey; if x>1 then x:=x-1 else
    if y>1 then begin x:=80; y:=y-1; end;
  gotoxy(x,y);
end;

procedure backs;
begin
  o(chr(8)); bs; write(' '); o(' '); o(chr(8)); bs;
end;

procedure sl1(i:str);
begin
  if (realsl<>255) or incom then begin
    assign(sysopf,'gfiles\sysop.log'); {$I-} append(sysopf);{$I+}
    if ioresult<>0 then
      rewrite(sysopf);
    writeln(sysopf,i);
    close(sysopf);
  end;
end;

procedure sysoplog(i:str);
begin
  sl1('   '+i);
end;

function tch(i:str):str;
begin
  if length(i)>2 then i:=copy(i,length(i)-1,2) else
    if length(i)=1 then i:='0'+i;
  tch:=i;
end;

FUNCTION TIME:STR;
VAR REG: RECORD
           AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS: INTEGER;
         END;
    H,M,S:string[4];
BEGIN
  reg.ax:=$2c00; intr($21,reg);
  str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s);
  time:=tch(h)+':'+tch(m)+':'+tch(s);
END;

FUNCTION DATE:STR;
VAR REG: RECORD
           AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS: INTEGER;
         END;
    M,D,Y:STRing[4];
BEGIN
  reg.ax:=$2a00; msdos(reg); str(reg.cx,y); str(reg.dx mod 256,d);
  str(reg.dx shr 8,m);
  date:=tch(m)+'/'+tch(d)+'/'+tch(y);
END;

FUNCTION value(I:str):INTEGER;
VAR N,N1:INTEGER;
BEGIN
  VAL(I,N,N1);
  IF N1<>0 THEN BEGIN
    I:=COPY(I,1,N1-1);
    VAL(I,N,N1)
  END;
  VaLue:=N;
  if i='' then value:=0;
END;


function cstr(i:integer):str;
var c:str;
begin
  str(i,c); cstr:=c;
end;

function nam:str;
var s:str; i:integer; tf:boolean;
begin
  s:=thisuser.name;
  tf:=true;
  for i:=1 to length(s) do
    if s[i]<'A' then
      tf:=true
    else begin
      if (s[i]<='Z') and not tf then
        s[i]:=chr(ord(s[i])+32);
      tf:=false;
    end;
  nam:=s+' #'+cstr(usernum);
end;


function leapyear(yr:integer):boolean;
begin
  leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
end;

function days(mo,yr:integer):integer;
var d:integer;
begin
  d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
  if (mo=2) and leapyear(yr) then d:=d+1;
  days:=d;
end;

function daycount(mo,yr:integer):integer;
var m,t:integer;
begin
  t:=0;
  for m:=1 to (mo-1) do t:=t+days(m,yr);
  daycount:=t;
end;

function daynum(dt:str):integer;
var d,m,y,t,c:integer;
begin
  t:=0;
  m:=value(copy(dt,1,2));
  d:=value(copy(dt,4,2));
  y:=value(copy(dt,7,2))+1900;
  for c:=1985 to y-1 do
    if leapyear(c) then t:=t+366 else t:=t+365;
  t:=t+daycount(m,y)+(d-1);
  daynum:=t;
  if y<1985 then daynum:=0;
end;

function dat:str;
var ap,x,y:str; i:integer;
begin
  case daynum(date) mod 7 of
    0:x:='Tue';
    1:x:='Wed';
    2:x:='Thu';
    3:x:='Fri';
    4:x:='Sat';
    5:x:='Sun';
    6:x:='Mon';
  end;
  case value(copy(date,1,2)) of
    1:y:='Jan';
    2:y:='Feb';
    3:y:='Mar';
    4:y:='Apr';
    5:y:='May';
    6:y:='Jun';
    7:y:='Jul';
    8:y:='Aug';
    9:y:='Sep';
    10:y:='Oct';
    11:y:='Nov';
    12:y:='Dec';
  end;
  x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
  y:=time; i:=value(copy(y,1,2));
  if i>11 then ap:='pm' else ap:='am';
  if i>12 then i:=i-12;
  if i=0 then i:=12;
  dat:=cstr(i)+copy(y,3,3)+' '+ap+'  '+x;
end;

function cdet:boolean;
begin
  cdet:=(port[base+6] and 128)<>0;
end;

procedure checkhangup;
begin
  if incom and not cdet and (not hangup) then begin
    hangup:=true; hungup:=true;
  end;
end;

procedure topscr; forward;
procedure skey(c:char); forward;
procedure getkey(var c:char); forward;

procedure pr1(i:str);
var c:integer;
begin
  for c:=1 to length(i) do o1(i[c]);
end;

procedure pr(i:str);
begin
  pr1(i+#13);
end;

procedure prompt(i:str);
var c:integer; cc:char;
begin
 checkhangup;
 if not hangup then begin
  for c:=1 to length(i) do begin
    if (not ((i[c]=chr(7)) and (incom))) and (i[c]<>chr(12)) and (i<>#1) then write(i[c]);
    if chatcall then sound(1000);
    o(i[c]);
    if i[c]>#31 then thisline:=thisline+i[c];
    if i[c]=#8 then if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
    if i[c]=chr(12) then begin lil:=0; clrscr; topscr; end;
    if i[c]=chr(13) then begin pap:=0; thisline:=''; end;
    nosound;
    if i[c]=chr(10) then begin
      lil:=lil+1;
      if (lil>=thisuser.pagelen-1) then begin
        lil:=0;
        if pause in thisuser.defaults then begin
          prompt('(-*-)');
          getkey(cc); skey(cc); prompt(' '+chr(8));
          for cc:='A' to 'E' do
            prompt(chr(8)+' '+chr(8));
        end;
      end;
    end;
  end;
 end;
end;

procedure print(i:str);
begin
  prompt(i+chr(13)+chr(10))
end;


procedure nl;
begin
  prompt(chr(13)+chr(10))
end;

procedure tleft;
var x,y:integer;
begin
 if okt then begin
  x:=wherex; y:=wherey; window(1,1,80,4);
  gotoxy(72,3);if chatcall then begin
    write('CHAT ON');
    if alert in thisuser.option then begin
      gotoxy(72,3);
      write('ALERT  ');
    end;
  end else write('       ');
  gotoxy(56,3); if sysop1 then write('Sysop Available') else
    write('----- ---------');
  if useron then begin
    gotoxy(35,3); if thisuser.ontoday<>1 then write('ML=',extramsgs+seclev[thisuser.sl].mallowed-mread,'   ');
    gotoxy(45,3); write('TL=',((seclev[thisuser.sl].ttime*60+extratime+timeon-timer)/60):6:2,'  ');
  end;
  if hangup then begin
    gotoxy(72,3);
    write('HANG UP');
  end;
  window(1,5,80,25);gotoxy(x,y);
  if timer<timeon then timeon:=timeon-24.0*60*60;
  if not ch and ((seclev[thisuser.sl].ttime*60+extratime+timeon-timer)<0) and useron then
  begin nl; print('Time expired.'); hangup:=true; end;
  checkhangup;
 end;
end;


procedure prestrict(u:userrec);
var r:restrictions;
begin
  for r:=rlogon to rmsg do
    if r in u.ac then write(copy('LCVBA*PEKM',ORD(R)+1,1)) else write(' ');
  writeln;
end;

procedure ff(i:integer);
begin
  while wherex<i do write(' ');
end;

procedure topscr;
var c:char; x,y,i:integer;
begin
 if (usernum<>0) and okt then begin
  x:=wherex; y:=wherey;
  window(1,1,80,5);
  gotoxy(1,1); write(chr(186),' ',nam); ff(35);
  with thisuser do begin
    write(realname);ff(50);write(ph);ff(65);
    if laston<>date then write(laston);
    ff(76); if date=laston then write(ontoday); ff(79);
    write(' ',chr(186));gotoxy(1,2);
    write(chr(186),' SL=',sl);ff(10);write('AR=');
    for c:='A' to 'G' do if c in ar then write(c) else write(' ');
    write(' LO=',loggedon);
    ff(28);write('P=',msgpost);ff(35);write('E=',emailsent);
    ff(42);write('F=',feedback);ff(48);
    write('W=',waiting);ff(54);
    if not useron then write('"',pw,'"') else write('SC=',thisuser.linelen,'X',
      thisuser.pagelen,'   ');
    ff(68);write('FW=',fw); ff(74); write('D=',thisuser.dsl);
    gotoxy(80,2);write(#186);
    gotoxy(1,3);write(#186,' AC='); prestrict(thisuser);
    gotoxy(17,3);write('C=',comptyp[thisuser.comptype]);
    gotoxy(80,3);write(chr(186));
    gotoxy(1,4);write(chr(200));
    for i:=2 to 79 do
      write(chr(205));
    write(chr(188));
  end;
  window(1,5,80,25);gotoxy(x,y);
  tleft;
 end;
end;

function empty:boolean;
begin
  if incom then empty:=not commpressed else empty:=true;
  if keypressed then empty:=false;
  if hangup then begin dump; empty:=true; end;
end;

function inkey:char;
var c:char;
begin
  c:=chr(0); inkey:=chr(0);
  if keypressed then begin
    read(kbd,c); if c=chr(27) then
      if keypressed then begin
        read(kbd,c);
        c:=chr(ord(c) or 128);
      end;
    inkey:=c;
  end else begin
    if commpressed and incom then begin
      inkey:=cinkey;
    end;
  end;
end;

procedure oc(c:char);
begin
  if c=chr(8) then bs else if c<>chr(0) then write(C);
  o(c);
end;

procedure outkey(c:char);
begin
  if (c<>chr(12)) and (not ((c=chr(7)) and (incom))) then if c=chr(8) then bs else if c<>#0 then write(c);
  if (not echo) and (c>=' ') then c:='X';
  o(c);
  if c=chr(12) then begin clrscr; topscr; end;
  if c=#7 then begin o(#0); o(#0); o(#0); o(#0); end;
end;

procedure phelp; forward;
procedure ptime; forward;


procedure getkey;
var p:integer; t:real; tf,t1:boolean;
begin
 if buf<>'' then begin
   c:=buf[1]; buf:=copy(buf,2,length(buf)-1);
 end else if not empty then c:=inkey else begin
 p:=1; t:=timer; t1:=false; tf:=false; lil:=0;
 c:=chr(0);
  while (c=chr(0)) and not hangup do begin
    c:=inkey;
    if empty and (c=chr(0)) then begin
      if (spcsr in thisuser.defaults) then begin
        oc(cursor[p]); t1:=true;
        p:=p+1; if p>length(cursor) then p:=1;
      end;
    end;
    if (timer-t)>180 then begin nl;
      print('Call back later when you are there.');hangup:=true;
      sysoplog('!-!-! TIMEOUT !-!-!');
    end;
    if ((timer-t)>90) and (not tf) then begin tf:=true; outkey(chr(7)); end;
    checkhangup;
  end;
if (spcsr in thisuser.defaults) and t1 then begin
 if (p mod 2)=0 then
   oc(chr(8));
 if (c<' ') or (c>=chr(127)) then begin oc(' '); oc(chr(8)); end;
end;
end;
if c=chr(127) then c:=chr(8);
if ((c=#6) or (c=#4)) and macok then begin
  if c=#4 then
    buf:=thisuser.macro[1]
  else
    buf:=thisuser.macro[2];
  if buf<>'' then begin c:=buf[1]; buf:=copy(buf,2,length(buf)-1); end;
end;
end;

procedure cls;
begin
  outkey(chr(12));
end;


procedure chsl;
var ij,i:str; c:integer;
begin
 ij:=thisline;
 prompt('[WAIT]');
 writeln;writeln;write('Enter new SL: ');
 readln(i); if i<>'' then thisuser.sl:=value(i); writeln;
 if thisuser.sl=99 then begin
   write('Board #? '); thisuser.sbn:=0;
   readln(i); thisuser.sbn:=value(i);
   writeln;
 end;
 topscr; realsl:=thisuser.sl;
 i:=''; for c:=1 to 6 do i:=i+chr(8)+' '+chr(8);
 prompt(i);
 writeln; thisline:=ij; write(ij);
end;

procedure swac(var u:userrec;r:restrictions);
begin
  if r in u.ac then u.ac:=u.ac-[r] else u.ac:=u.ac+[r];
end;

procedure acch(c:char; var u:userrec);
begin
  case c of
    'L':swac(u,rlogon);
    'C':SWAC(u,RCHAT);
    'V':SWAC(u,RVALIDATE);
    'B':SWAC(u,RBACKSPACE);
    'A':SWAC(u,RAMSG);
    '*':SWAC(u,RPOSTAN);
    'P':SWAC(u,RPOST);
    'E':SWAC(u,REMAIL);
    'K':SWAC(u,RVOTING);
    'M':swac(u,rmsg);
  END;
end;

procedure chac(var thisuser:userrec);
var c:char; ij,i:str; cc:integer;
begin
  ij:=thisline;
  prompt('[WAIT]');
  writeln;writeln('LCVBA*PEKM');writeln;write('Which? '); read(kbd,c); c:=upcase(c); writeln(c); writeln;
  acch(c,thisuser);
  topscr;
  i:=''; for cc:=1 to 6 do i:=i+chr(8)+' '+chr(8);
  prompt(i);
  writeln;
  thisline:=ij; write(ij);
END;

procedure chat; forward;

procedure chdsl;
var ij,i:str; c:integer;
begin
 ij:=thisline;
 prompt('[WAIT]');
 writeln;writeln;
 writeln('UL=',thisuser.uploads,'-',thisuser.uk,'K   DL=',thisuser.downloads,'-',thisuser.dk,'K');
 write('Enter new DSL: ');
 readln(i); if i<>'' then thisuser.dsl:=value(i); writeln;
 i:=''; for c:=1 to 6 do i:=i+chr(8)+' '+chr(8);
 topscr;
 prompt(i);
 writeln; thisline:=ij; write(ij);
end;

procedure tfile;
var i:str; ii:integer;
bf:file of byte; cr:boolean;
begin
  if cfo then begin
    cfo:=false;
    close(cf);
    write('<CLOSED>');
  end else begin
    assign(cf,'gfiles\chat.msg');
    assign(bf,'gfiles\chat.msg'); cr:=false;
    {$I-} reset(bf); {$I+}
    if ioresult<>0 then cr:=true
    else begin
      if filesize(bf)=0 then cr:=true;
      close(bf);
    end;
    if cr then rewrite(cf) else append(cf);
    cfo:=true;
    i:=#13+#10+#13+#10+dat+#13+#10+'==============='+#13+#10;
    writeln(cf,i);
    write('<OPEN>');
  end;
end;

procedure skey;
var b:boolean;
begin
  case ord(c) of
      3:if spcsr in thisuser.defaults then
          thisuser.defaults:=thisuser.defaults-[spcsr] else
          thisuser.defaults:=thisuser.defaults+[spcsr];
     26:phelp;
     20:ptime;
    187:chsl;
    212:chdsl;
    188:chac(thisuser);
    189:begin
         if outcom then incom:=not incom;
         writeln; if incom then writeln('<INPUT ENABLED>')
           else writeln('<COM DISABLED>');
         writeln;dump;
         write(thisline);
       end;
    190:chatcall:=false;
    195:begin
          if thisuser.sl=255 then if realsl<>255 then begin
            thisuser.sl:=realsl; writeln;writeln;writeln('<SECLEV RESTORED>');
            writeln; write(thisline); end
          else else begin
            thisuser.sl:=255; writeln;writeln;writeln('<TEMP SYSOP GRANTED>');
            writeln; write(thisline);
          end; topscr;
        end;
    196:if not ch then chat;
    199:if ch then tfile;
    191:hangup:=true;
    192:tleft;
    193:begin b:=ch; ch:=true; extratime:=extratime-5*60; tleft; ch:=b;end;
    194:begin b:=ch; ch:=true; extratime:=extratime+5*60; tleft; ch:=b;end;
    218:begin b:=ch; ch:=true; extramsgs:=extramsgs-10; tleft; ch:=b;  end;
    219:begin b:=ch; ch:=true; extramsgs:=extramsgs+10; tleft; ch:=b;  end;
  end;
  if (c>chr(127)) and (c<>chr(196)) then c:=chr(0);
end;

procedure inli1(var i:str);
var cp:integer; c:char; cv,cc:integer;
begin
  cp:=1;
  i:='';
  if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1;end;
  repeat
    getkey(c); skey(c); checkhangup;
    case ord(c) of
      32..126:if (cp<79) then begin
                i[cp]:=c; cp:=cp+1; outkey(c);
              end;
      127,8:if cp>1 then begin c:=chr(8);
               prompt(c+' '+c); cp:=cp-1;
            end;
      24:begin
           for cv:=1 to cp-1 do prompt(chr(8)+' '+chr(8)); cp:=1;
         end;
       7:o(#7);
      23:if cp>1 then repeat
           prompt(chr(8)+' '+chr(8)); cp:=cp-1;
         until (cp=1) or (i[cp]=' ');
       9:begin
           cv:=5-(cp mod 5); if (cp+cv<79)  then
             for cc:=1 to cv do begin
               prompt(' ');
               i[cp]:=' '; cp:=cp+1;
             end;
         end;
  end;
  until (c=#13) or (cp=79) or hangup or (c=#196);
  if c=#196 then begin c:=#13; ch:=false; end;
  i[0]:=chr(cp-1);
  if c<>chr(13) then begin
    cv:=cp-1;
    while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
    if (cv>(cp div 2)) and (cv<>cp-1) then begin
      ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
      for cc:=cp-2 downto cv do prompt(' ');
      i[0]:=chr(cv-1);
    end;
  end;
  nl;
end;

procedure chat;
var c,ohl:char; tf:boolean; sp,xx:str; x:integer; t,t1:real;
begin
  sp:=thisline; ch:=true; chatcall:=false; tf:=echo; echo:=true;nl;nl; t:=timer;
  thisuser.option:=thisuser.option-[alert]; ohl:=helpl; helpl:=#0;
  print('Sysop''s here...'); nl;
  if chatr<>'' then begin
    writeln; writeln; writeln('Reason: ',chatr); writeln; writeln; chatr:='';
  end;
  repeat
    inli1(xx);
    if (xx='/quitchat') or (xx='/QUITCHAT') then begin
      t1:=timer; while (abs(t1-timer)<4.0) and (not keypressed) do;
      if not keypressed then ch:=false;
    end else if cfo then writeln(cf,xx);
  until (not ch) or hangup;
  nl;print('Chat mode over...'); nl;
  extratime:=extratime+timer-t; ch:=false; echo:=tf;
  if hangup and cfo then begin
    writeln(cf); writeln(cf,'<HANGUP>');
  end;
  prompt(sp); thisline:=sp;
  if cfo then begin cfo:=false; close(cf); end;
  helpl:=ohl;
end;

function yn:boolean;
var c:char;
begin
  if not hangup then begin
    repeat
      getkey(c);
      skey(c);
      c:=upcase(c);
    until (c='Y') or (c='N') or (c=chr(13)) or hangup;
    if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
    if hangup then yn:=false;
  end;
end;

procedure input1(var i:str; ml:integer; tf:boolean);
var cp:integer;
    c:char;
    r:real;
begin
 checkhangup;
 if not hangup then begin
  r:=timer;
  cp:=1;
  repeat
    getkey(c);
    skey(c);
    if c=#196 then r:=timer;
    if not tf then c:=upcase(c);
    if (c>=' ') and (c<chr(127)) then
      if cp<=ml then begin
      i[cp]:=c;
      cp:=cp+1;
      outkey(c);
      thisline:=thisline+c;
    end else else case ord(c) of
      127,8:if cp>1 then begin
               c:=chr(8);
               outkey(c);outkey(' '); outkey(c);
               cp:=cp-1;
               if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
             end;
      21,24:while cp<>1 do begin
               cp:=cp-1;
               outkey(#8);outkey(' '); outkey(#8);
               if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
             end;
    end;
    if (timer-r)>300.0 then hangup:=true;
  until (c=#13) or (c=#14) or hangup;
  i[0]:=chr(cp-1);
  nl;
 end;
end;

procedure input(var i:str; ml:integer);
begin
  input1(i,ml,false);
end;


procedure inputl(var i:str; ml:integer);
begin
  input1(i,ml,true);
end;

function find(c:char; s:str):boolean;
var i:integer; tf:boolean;
begin
  c:=upcase(c);
  tf:=false;
  for i:=1 to length(s) do
    if c=upcase(s[i]) then tf:=true;
  find:=tf;
end;

procedure onek(var c:char; ch:str);
 var i1,i:str; tf:boolean;
begin
  i1:=thisline; tf:=false;
  repeat
    if not(onekey in thisuser.defaults) then begin
      if tf then prompt(i1);
      input(i,3);
      if length(i)=1 then c:=i[1] else c:=' ';
    end else begin
      getkey(c);
      skey(c);
      c:=upcase(c);
    end;
    tf:=true;
  until find(c,ch) or hangup;
  if not find(c,ch) then c:=ch[1];
  if onekey in thisuser.defaults then print(''+c);
end;

procedure centre(var i:str);
begin
  if pap<>0 then nl;
  if i[1]=#2 then i:=copy(i,2,length(i)-1);
  if length(i)<thisuser.linelen then
    i:=copy('                                               ',1,
      (thisuser.linelen-length(i)) div 2)+i;
end;

procedure printa1(i:str; var abort,next:boolean);
var c:integer; cc:char;
 procedure wkey;
 begin
    while (not empty) and (not hangup) do begin
      cc:=inkey; skey(cc);
      if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
        abort:=true;
      if (cc=chr(14)) then begin abort:=true; next:=true; end;
      if (cc=chr(19)) or (cc='P') or (cc='p') then begin
        getkey(cc); skey(cc);
      end;
    end;
 end;

begin
 checkhangup;
 if not hangup then begin
  abort:=false; next:=false; c:=1;
  wkey;
  while (not abort) and (c-1<>length(i)) and (not hangup) do begin
    checkhangup;
    if i[c]=chr(8) then pap:=pap-1 else if i[c]<>chr(10) then pap:=pap+1;
    wkey;
    outkey(i[c]);
    c:=c+1;
  end;
 end else abort:=true;
end;

procedure printa(i:str; var abort,next:boolean);
var s:str; p,lp,rp:integer;
begin
  abort:=false;
  p:=1; rp:=0; lp:=1;
  if i[1]=#2 then begin
    if i[length(i)]=#1 then i:=copy(i,1,length(i)-1);
    centre(i);
    printa1(i,abort,next);
    nl;
  end else begin
    while (p<=length(i)) and (not abort) and (not hangup) do begin
      rp:=0;
      while (i[p]<>' ') and (p<=length(i)) and (not hangup) do begin
        if i[p]=chr(8) then rp:=rp-1 else
          if (i[p]<>#10) and (i[p]<>#1) then rp:=rp+1;
        p:=p+1;
      end;
      if i[p]=' ' then rp:=rp+1;
      s:=copy(i,lp,(p-lp+1)); p:=p+1; lp:=p;
      if s[length(s)]=#1 then s:=copy(s,1,length(s)-1);
      if s<>'' then if (copy(s,length(s),1)<>' ') and (i[length(i)]<>#1) then s:=s+' ';
      if (pap+rp>=thisuser.linelen) then nl;
      printa1(s,abort,next);
    end;
    if not abort then printa1('',abort,next);
    if abort or (i[length(i)]=#1) or (length(i)=0) then nl;
  end;
end;

procedure printacr(i:str; var abort,next:boolean);
begin
 if not abort then
  if i[length(i)]=#1 then
    printa(i,abort,next)
  else
    printa(i+#1,abort,next);
end;

function tlef:str;
var rl:real; inte:integer; i,ii:str;
begin
  rl:=(seclev[thisuser.sl].ttime*60.0+extratime+timeon-timer);
  if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
  inte:=trunc(rl);
  i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
  if length(ii)=1 then ii:='0'+ii; i:=i+ii+':';
  ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
  tlef:=i+ii;
end;

procedure phelp;
var i,lli:str; c:integer; abort,next:boolean;
begin
  ihelp:=true;
  lli:=thisline;
  if helpl in ['0'..'^'] then
    if helpi[helpl]>0 then begin
      cls;
      c:=helpi[helpl];
      i:=''; abort:=false;
      while (help[c]<>'|') and (not abort) do begin
        if help[c]=#10 then begin
          printacr(i,abort,next);
          i:='';
        end else
          if help[c]<>#13 then
            i:=i+help[c];
        c:=c+1;
      end;
      nl; nl; nl;
      prompt(lli);
    end;
  ihelp:=false;
end;

procedure ptime;
var i:str;
begin
  if useron then begin
    i:=thisline;
    nl; nl; print(dat);
    print('Time left: '+tlef);
    nl; prompt(i);
  end;
end;